home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Belgian Amiga Club - ADF Collection
/
BS1 part 41.zip
/
BS1 part 41
/
Compute`s Amiga resource 1.adf
/
Source
/
PowerPoker
/
powerpoker.mod
Wrap
Text File
|
1989-02-07
|
10KB
|
416 lines
MODULE PowerPoker;
FROM TermInOut IMPORT WriteLn, WriteString;
FROM RandomNumbers IMPORT Random, Seed;
FROM ReadPict IMPORT ReadPicture, ILBMFrame;
FROM IFF IMPORT IFFP;
FROM AmigaDOS IMPORT Open, Close, FileHandle, ModeOldFile;
FROM AmigaDOSProcess IMPORT Delay;
FROM SYSTEM IMPORT ADR, BYTE, WORD;
FROM RemAlloc IMPORT ChipAlloc, RemFree;
FROM SimpleScreens IMPORT CreateScreen, ScreenOptFlags;
FROM SimpleWindows IMPORT CreateWindow;
FROM Views IMPORT LoadRGB4;
FROM Graphics IMPORT BitMap;
FROM Drawing IMPORT SetAPen, RectFill;
FROM SimpleIDCMP IMPORT MsgData, WindowProc, ProcIMsg;
FROM Tasks IMPORT SignalSet, Wait;
FROM Ports IMPORT GetMsg;
FROM Rasters IMPORT RastPort;
FROM Views IMPORT ViewPort, SetRGB4;
FROM InputEvents IMPORT IEQualifier, IEQualifierSet;
FROM Memory IMPORT MemReqSet, AvailMem;
FROM Blit IMPORT BltBitMap, MinTermFlagsSet, WaitTOF, BltBitMapRastPort,
ClipBlit;
FROM SimpleMenus IMPORT BeginMenuStrip, EndMenuStrip, FreeMenuStrip, AddMenu,
AddMenuItem, MenuItemOpt;
FROM Intuition IMPORT CloseScreen, ScreenPtr, IDCMPFlagsSet, WindowFlagsSet,
WindowFlags, WindowPtr, CloseWindow, Window, IntuiMessagePtr, IDCMPFlags,
ClearMenuStrip, SetMenuStrip, MenuPtr, MenuItemFlagsSet, MenuItemFlags,
MenuItemMutualExcludeSet, HighComp, ITEMNUM, SelectDown, ScreenFlags,
ScreenFlagsSet, ScreenToFront, ScreenToBack, RethinkDisplay, CurrentTime;
CONST
CopyFlags = MinTermFlagsSet{6,7};
XORFlags = MinTermFlagsSet{5,6};
WIDCMP = IDCMPFlagsSet{MenuPick,MouseButtons,MenuVerify};
WFlags = WindowFlagsSet{Activate,Borderless};
MFlags = MenuItemFlagsSet{ItemText,ItemEnabled,CommSeq}+HighComp;
MIMEFlags = MenuItemMutualExcludeSet{};
Shifts = IEQualifierSet{IEQualifierLShift,IEQualifierRShift,
IEQualifierCapsLock};
IEQNULL = IEQualifierSet{};
All = BYTE(0FFH);
ScrFlags = ScreenFlagsSet{ScreenBehind};
VAR Scr: ScreenPtr;
sig: SignalSet;
msg: IntuiMessagePtr;
wp: WindowProc;
ms: MenuPtr;
rp: RastPort;
vp: ViewPort;
i, j, k, Suit, Rank, Card, Best, Score, HighScore : CARDINAL;
pic, pic2: FileHandle;
res: IFFP;
frame: ILBMFrame;
bm, bm2: BitMap;
win : WindowPtr;
name: ARRAY [1..18] OF CHAR;
Table: ARRAY [1..5],[1..5] OF BOOLEAN;
TRank, TSuit: ARRAY [1..5],[1..5] OF CARDINAL;
result, Restart, Done, AllSameSuit: BOOLEAN;
DeckSuit, DeckRank: ARRAY [1..52] OF CARDINAL;
InRow, InColumn, Hand : ARRAY [1..5] OF CARDINAL;
Hold : ARRAY [1..14] OF CARDINAL;
Power : ARRAY [1..4] OF CARDINAL;
ScoreTable : ARRAY [0..9] OF CARDINAL;
PROCEDURE Swap(VAR x,y:CARDINAL);
VAR t: CARDINAL;
BEGIN
t := x;
x := y;
y := t;
END Swap;
PROCEDURE WriteScore(Score,LeftPlace: CARDINAL);
VAR Digit: CARDINAL;
BEGIN
j := Score;
FOR i := 1 TO 4 DO
Digit := j DIV Power[i];
BltBitMapRastPort(bm2,10*Digit+21,1,rp,LeftPlace+i*9,32,8,7,CopyFlags);
j := j-Digit*Power[i];
END;
END WriteScore;
PROCEDURE Evaluate(AllSameSuit:BOOLEAN);
VAR
i, j, temp, One, Two, Three, Four: CARDINAL;
Straight, Royal: BOOLEAN;
BEGIN
One := 0; Two := 0; Three := 0; Four := 0;
FOR i := 2 TO 14 DO
Hold[i] := 0;
END;
FOR i := 1 TO 5 DO
INC(Hold[Hand[i]]);
END;
Hold[1] := Hold[14];
FOR i := 2 TO 14 DO
CASE Hold[i] OF
1: INC(One);|
2: INC(Two);|
3: INC(Three);|
4: INC(Four);
END;
END;
Best := 0;
IF Four=1 THEN
Best := 7; (*Four Of A Kind*)
END;
IF (Three=1) THEN
IF (Two=1) THEN
Best := 5; (*Full House*)
ELSE
Best := 4; (*Three Of A Kind*)
END;
END;
IF Best=0 THEN
IF Two=2 THEN
Best := 2; (*Two Pair*)
END;
IF Two=1 THEN
Best := 1; (*One Pair*)
END;
END;
Straight := FALSE;
Royal := FALSE;
IF One=5 THEN
FOR i := 1 TO 4 DO
FOR j := i+1 TO 5 DO
IF Hand[i]>Hand[j] THEN
Swap(Hand[i],Hand[j]);
END;
END;
END;
Straight := ((Hand[5]-Hand[1])=4) OR
((Hand[5]=14) AND (Hand[1]=2) AND (Hand[4]=5));
Royal := (Hand[5]=14) AND (Hand[1]=10);
END;
IF (Straight OR Royal) AND (Best<6) THEN
Best := 6; (*Straight*)
END;
IF AllSameSuit THEN
IF (Best<3) THEN
Best := 3;
END;
IF Straight THEN
Best := 8; (*Straight Flush*)
END;
IF Royal THEN
Best := 9; (*Royal Flush*)
END;
END;
Score := Score+ScoreTable[Best];
WriteScore(Score,435);
IF Score>1000 THEN
SetRGB4(vp,3,15,10,5);
RethinkDisplay;
END;
IF Score>HighScore THEN
HighScore := Score;
WriteScore(HighScore,554);
END;
END Evaluate;
PROCEDURE MenuHandler(VAR w:Window; VAR msg: MsgData; menu: CARDINAL);
VAR men,ite,sub: CARDINAL;
BEGIN
ite := ITEMNUM(menu);
CASE ite OF
0: Restart := TRUE;|
1: ScreenToBack(Scr^);|
2: Done := TRUE;
END;
END MenuHandler;
PROCEDURE SumRow(Row: CARDINAL);
VAR temp: CARDINAL;
BEGIN
temp := Row*38-32;
FOR i := 1 TO 6 DO
res:=BltBitMap(bm,8,temp,Scr^.BitMap,8,temp,336,33,XORFlags,BYTE(1),NIL);
Delay(12);
END;
AllSameSuit := TRUE;
FOR i := 1 TO 5 DO
Hand[i] := TRank[i,Row];
IF TSuit[i,Row]<>TSuit[1,Row] THEN
AllSameSuit := FALSE;
END;
END;
Evaluate(AllSameSuit);
END SumRow;
PROCEDURE SumColumn(Column: CARDINAL);
VAR temp: CARDINAL;
BEGIN
temp := Column*66-52;
FOR i := 1 TO 6 DO
res:=BltBitMap(bm,temp,6,Scr^.BitMap,temp,6,60,186,XORFlags,BYTE(1),NIL);
Delay(12);
END;
AllSameSuit := TRUE;
FOR i := 1 TO 5 DO
Hand[i] := TRank[Column,i];
IF TSuit[Column,i]<>TSuit[Column,1] THEN
AllSameSuit := FALSE;
END;
END;
Evaluate(AllSameSuit);
END SumColumn;
PROCEDURE MoveCard(x,y:CARDINAL):BOOLEAN;
VAR temp: BOOLEAN;
BEGIN
temp := FALSE;
IF (x>0) AND (x<6) AND (y>0) AND (y<6) THEN
temp := ~Table[x,y];
IF temp THEN
ClipBlit(rp,468,159,rp,x*66-52,y*38-32,58,32,CopyFlags);
Table[x,y] := TRUE;
TRank[x,y] := Rank;
TSuit[x,y] := Suit;
SetAPen(Scr^.RastPort,8);
RectFill(Scr^.RastPort,469,160,469+56,160+30);
INC(InRow[y]);
IF InRow[y]=5 THEN
SumRow(y);
END;
INC(InColumn[x]);
IF InColumn[x]=5 THEN
SumColumn(x);
END;
END;
END;
RETURN temp;
END MoveCard;
PROCEDURE DrawCard(Suit, Rank: CARDINAL);
VAR temp1, temp2 : CARDINAL;
BEGIN
SetAPen(Scr^.RastPort,1);
RectFill(Scr^.RastPort,469,160,469+56,160+30);
IF Suit>2 THEN
temp1 := 49;
ELSE
temp1 := 89;
END;
temp2 := Rank*12+1;
BltBitMapRastPort(bm2,113,Suit*24-12,rp,486,169,24,13,CopyFlags);
BltBitMapRastPort(bm2,temp1,temp2,rp,469,160,18,11,CopyFlags);
BltBitMapRastPort(bm2,temp1,temp2,rp,506,180,18,11,CopyFlags);
END DrawCard;
PROCEDURE Shuffle;
VAR i,j: CARDINAL;
BEGIN
FOR i := 1 TO 52 DO
DeckSuit[i] := i MOD 4+1;
DeckRank[i] := i MOD 13+2;
END;
FOR i := 1 TO 52 DO
j := CARDINAL(Random(52))+1;
Swap(DeckSuit[i],DeckSuit[j]);
Swap(DeckRank[i],DeckRank[j]);
END;
Score := 0;
Card := 1;
BltBitMapRastPort(bm2,152,14,rp,388,30,216,11,CopyFlags);
WriteScore(HighScore,554);
Suit := DeckSuit[Card];
Rank := DeckRank[Card];
DrawCard(Suit,Rank);
Card := 2;
END Shuffle;
PROCEDURE MouseHandler(VAR w:Window; VAR msg: MsgData; buttons: CARDINAL);
BEGIN
IF buttons=SelectDown THEN
WITH msg DO
result := MoveCard((MouseX+52) DIV 66,(MouseY+32) DIV 38);
IF result THEN
Suit := DeckSuit[Card];
Rank := DeckRank[Card];
DrawCard(Suit,Rank);
INC(Card);
END;
END;
END;
END MouseHandler;
PROCEDURE MenuVerifyHandler(VAR w:Window; VAR mag:MsgData);
BEGIN
END MenuVerifyHandler;
BEGIN
HighScore := 0;
Power[1] := 1000; Power[2] := 100; Power[3] := 10; Power[4] := 1;
ScoreTable[0] := 0; ScoreTable[1] := 10; ScoreTable[2] := 30;
ScoreTable[3] := 50; ScoreTable[4] := 60; ScoreTable[5] := 100;
ScoreTable[6] := 120; ScoreTable[7] := 160; ScoreTable[8] := 300;
ScoreTable[9] := 400;
WriteLn;
WriteString(" Power Poker");
WriteLn;
WriteString("©1989 COMPUTE! Publications");
WriteLn;
WriteString(" All Rights Reserved");
WriteLn;
WriteString(" Please Wait");
WriteLn;
IF AvailMem(MemReqSet{1})<250000D THEN
WriteString("==INSUFFICIENT MEMORY==");
WriteLn;
Delay(200);
RETURN;
END;
name := "pp.bak";
pic := Open(ADR(name), ModeOldFile);
Close(pic);
name := "pp.objs";
pic2 := Open(ADR(name), ModeOldFile);
Close(pic2);
IF (pic=NIL) OR (pic2=NIL) THEN
WriteString("==CAN'T FIND GRAPHICS FILES==");
WriteLn;
Delay(200);
RETURN;
END;
WITH wp DO
procMouseButtons := MouseHandler;
procMenuPick := MenuHandler;
procMenuVerify := MenuVerifyHandler;
END;
BeginMenuStrip();
AddMenu(ADR(" Power Poker "));
AddMenuItem(ADR(" New Game "));
MenuItemOpt(MFlags,MIMEFlags,"N");
AddMenuItem(ADR(" Screen To Back "));
MenuItemOpt(MFlags,MIMEFlags,"W");
AddMenuItem(ADR(" Quit "));
MenuItemOpt(MFlags,MIMEFlags,"Q");
ms := EndMenuStrip();
ScreenOptFlags := WORD(ScrFlags);
Scr := CreateScreen(640,200,4,NIL);
win := CreateWindow(0,0,640,200,WIDCMP,WFlags,NIL,Scr,NIL);
rp := Scr^.RastPort;
vp := Scr^.ViewPort;
SetMenuStrip(win^,ms^);
name := "pp.bak";
pic := Open(ADR(name), ModeOldFile);
res := ReadPicture(pic,bm,frame,ChipAlloc);
Close(pic);
LoadRGB4(Scr^.ViewPort,ADR(frame.colorMap),16);
name := "pp.objs";
pic := Open(ADR(name), ModeOldFile);
res := ReadPicture(pic,bm2,frame,ChipAlloc);
Close(pic);
BltBitMapRastPort(bm,0,0,rp,0,0,640,200,CopyFlags);
ScreenToFront(Scr^);
CurrentTime(ADR(Seed),ADR(Seed));
Delay(100);
Shuffle;
REPEAT
FOR i := 1 TO 5 DO
FOR j := 1 TO 5 DO
Table[i,j] := FALSE;
SetAPen(Scr^.RastPort,8);
RectFill(Scr^.RastPort,i*66-51,j*38-31,i*66+5,j*38-1);
END;
InRow[i] := 0;
InColumn[i] := 0;
END;
Restart := FALSE;
WHILE (~Done) AND (~Restart) DO
sig := Wait(SignalSet{CARDINAL(win^.UserPort^.mpSigBit)});
LOOP
msg := GetMsg(win^.UserPort^);
IF (msg=NIL) THEN
EXIT;
END;
ProcIMsg(wp,msg);
END;
END;
Shuffle;
UNTIL (~Restart);
ClearMenuStrip(win^);
CloseWindow(win^);
CloseScreen(Scr^);
FreeMenuStrip(ms^);
RemFree(bm.Planes[0]);
RemFree(bm2.Planes[0]);
END PowerPoker.